home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
Dev
/
Oberon
/
source
/
Library
/
BufIO.mod
< prev
next >
Wrap
Text File
|
1995-01-25
|
11KB
|
371 lines
(***************************************************************************
$RCSfile: BufIO.mod $
Description: Simple formatted I/O using the standard input and output
handles.
Created by: fjc (Frank Copeland)
$Revision: 1.1 $
$Author: fjc $
$Date: 1995/01/26 00:40:27 $
Copyright © 1994, Frank Copeland.
This file is part of the Oberon-A Library.
See Oberon-A.doc for conditions of use and distribution.
Log entries are at the end of the file.
***************************************************************************)
<* STANDARD- *>
MODULE BufIO;
IMPORT SYSTEM, Dos, Reals, WbConsole;
CONST maxD = 9;
VAR W, R: Dos.FileHandlePtr;
PROCEDURE Write* (fh: Dos.FileHandlePtr; ch: CHAR);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPutC (fh, ORD (ch)) = -1 THEN (* Error *) END
END Write;
PROCEDURE WriteLn* (fh: Dos.FileHandlePtr);
BEGIN
Write (fh, "\n")
END WriteLn;
<*$CopyArrays-*>
PROCEDURE WriteStr* (fh: Dos.FileHandlePtr; str: ARRAY OF CHAR);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPuts (fh, str) THEN (* Error *) END
END WriteStr;
<*$CopyArrays-*>
PROCEDURE WriteF* (fh: Dos.FileHandlePtr; fs : ARRAY OF CHAR; VAR f : ARRAY OF SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.VFPrintf (fh, fs, f) = -1 THEN (* Error *) END
END WriteF;
<*$CopyArrays-*>
PROCEDURE WriteF1* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR; p1 : SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1) = -1 THEN (* Error *) END
END WriteF1;
<*$CopyArrays-*>
PROCEDURE WriteF2* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2) = -1 THEN (* Error *) END
END WriteF2;
<*$CopyArrays-*>
PROCEDURE WriteF3* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2, p3: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2, p3) = -1 THEN (* Error *) END
END WriteF3;
<*$CopyArrays-*>
PROCEDURE WriteF4* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2, p3, p4: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2, p3, p4) = -1 THEN (* Error *) END
END WriteF4;
<*$CopyArrays-*>
PROCEDURE WriteF6* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6) = -1 THEN (* Error *) END
END WriteF6;
<*$CopyArrays-*>
PROCEDURE WriteF7* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7) = -1 THEN (* Error *) END
END WriteF7;
<*$CopyArrays-*>
PROCEDURE WriteF8* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8) = -1 THEN (* Error *) END
END WriteF8;
<*$CopyArrays-*>
PROCEDURE WriteF9* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8, p9) = -1 THEN (* Error *) END
END WriteF9;
<*$CopyArrays-*>
PROCEDURE WriteF10* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9, p10: SYSTEM.LONGWORD);
BEGIN
IF fh = NIL THEN fh := W END;
IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10) = -1 THEN (* Error *) END
END WriteF10;
PROCEDURE WriteInt* (fh: Dos.FileHandlePtr; i: LONGINT);
BEGIN
WriteF1 (fh, "%ld", i)
END WriteInt;
PROCEDURE WriteHex* (fh: Dos.FileHandlePtr; i : LONGINT);
BEGIN
WriteF1 (fh, "%lx", i)
END WriteHex;
(*
* The following WriteReal* and WriteLongReal* procedures have been pinched
* from Module Texts and have been somewhat modified from the original code
* described in "Project Oberon".
*)
PROCEDURE WriteReal* (fh: Dos.FileHandlePtr; x: REAL; n: INTEGER );
VAR e : INTEGER;
x0: REAL;
d : ARRAY maxD OF CHAR;
BEGIN
(*
* This implementation uses Motorola FFP format reals instead of IEEE
* single-precision reals. The Project Oberon code has been modified to
* remove the special-case handling of unnormal and NaN values and assume
* 7-bit exponents instead of 8-bit.
*)
e := Reals.Expo (x);
IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
REPEAT Write (fh, " "); DEC (n) UNTIL n <= 8;
(* there are 2 < n <= 8 digits to be written *)
IF x < 0.0 THEN Write (fh, "-"); x := -x ELSE Write (fh, " ") END;
e := (e - 64) * 77 DIV 256;
IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
Reals.Convert (x, n, d);
DEC (n); Write (fh, d [n]); Write (fh, ".");
REPEAT DEC (n); Write (fh, d [n]) UNTIL n = 0;
Write (fh, "E");
IF e < 0 THEN Write (fh, "-"); e := -e ELSE Write (fh, "+") END;
Write (fh, CHR (e DIV 10 + 30H)); Write (fh, CHR (e MOD 10 + 30H))
END WriteReal;
PROCEDURE WriteRealFix* (fh: Dos.FileHandlePtr; x: REAL; n, k: INTEGER);
VAR e, i: INTEGER;
sign: CHAR;
x0: REAL;
d : ARRAY maxD OF CHAR;
PROCEDURE seq (ch: CHAR; n: LONGINT);
BEGIN
WHILE n > 0 DO Write (fh, ch); DEC (n) END
END seq;
PROCEDURE dig (n : INTEGER);
BEGIN
WHILE n > 0 DO
DEC (i); Write (fh, d [i]); DEC (n)
END;
END dig;
BEGIN (*
* This implementation uses Motorola FFP format reals instead of IEEE
* single-precision reals. The Project Oberon code has been modified to
* remove the special-case handling of unnormal and NaN values and assume
* 7-bit exponents instead of 8-bit.
*)
IF k < 0 THEN k := 0 END;
e := (Reals.Expo (x) - 64) * 77 DIV 256;
IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
(* 1 <= x < 10 *)
IF k + e >= maxD - 1 THEN k := maxD - 1 - e
ELSIF k + e < 0 THEN k := -e; x := 0.0
END;
x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
IF x >= 10.0 * x0 THEN INC (e) END;
(* e = no. of digits before decimal point *)
INC (e); i := k + e; Reals.Convert (x, i, d);
IF e > 0 THEN
seq (" ", n - e - k - 2); Write (fh, sign); dig (e); Write (fh, ".");
dig (k)
ELSE
seq (" ", n - k - 3); Write (fh, sign); Write (fh, "0"); Write (fh, ".");
seq ("0", -e); dig (k + e)
END; (* ELSE *)
END WriteRealFix;
PROCEDURE WriteRealHex* (fh: Dos.FileHandlePtr; x: REAL);
VAR d : ARRAY 9 OF CHAR;
BEGIN
Reals.ConvertH (x, d); d [8] := 0X; WriteStr (fh, d)
END WriteRealHex;
PROCEDURE WriteLongReal* (fh: Dos.FileHandlePtr; x: LONGREAL; n: INTEGER);
BEGIN
(*
* In this implementation, LONGREAL and REAL types are the same, so this
* procedure is implemented as a call to WriteReal ().
*)
WriteReal (fh, SHORT (x), n)
END WriteLongReal;
PROCEDURE WriteLongRealHex* (fh: Dos.FileHandlePtr; x: LONGREAL);
BEGIN
(*
* In this implementation, LONGREAL and REAL types are the same, so this
* procedure is implemented as a call to WriteRealHex ().
*)
WriteRealHex (fh, SHORT (x))
END WriteLongRealHex;
PROCEDURE Read* (fh: Dos.FileHandlePtr; VAR ch : CHAR);
VAR i: LONGINT;
BEGIN
IF fh = NIL THEN fh := R END;
i := Dos.FGetC (fh);
IF i = -1 THEN
ch := 0X
ELSE ch := CHR (SHORT (SHORT (i)))
END
END Read;
PROCEDURE ReadStr* (fh: Dos.FileHandlePtr; VAR str : ARRAY OF CHAR);
VAR ch: CHAR;
index, limit: INTEGER;
BEGIN
(* Skip white space *)
REPEAT Read (fh, ch) UNTIL (ch # " ") & (ch # 09X);
(* Read until control char *)
index := 0; limit := SHORT (LEN (str));
WHILE (ch >= " ") & (index < limit) DO
str [index] := ch; INC (index); Read (fh, ch);
END; (* WHILE *)
str [index] := 0X;
(* Skip rest of line if any *)
WHILE ch >= " " DO Read (fh, ch) END
END ReadStr;
PROCEDURE ReadHexDigit (fh: Dos.FileHandlePtr; i: INTEGER): BOOLEAN;
VAR ch: CHAR;
BEGIN
Read (fh, ch);
ch := CAP (ch);
IF ("0" <= ch) & (ch <= "9") THEN
i := ORD (ch) - ORD ("0")
ELSIF ("A" <= ch) & (ch <= "F") THEN
i := ORD (ch) - ORD ("A") + 10
ELSE
i := 0;
IF Dos.UnGetC (fh, -1) = -1 THEN (* Error *) END;
RETURN FALSE (* error *)
END;
RETURN TRUE (* success *)
END ReadHexDigit;
PROCEDURE ReadShortHex* (fh: Dos.FileHandlePtr; VAR i: SHORTINT): BOOLEAN;
VAR n, j: INTEGER;
BEGIN
i := 0;
FOR n := 1 TO 2 DO
IF ReadHexDigit (fh, j) THEN
i := i*16 + SHORT (j)
ELSE IF n > 1 THEN
RETURN TRUE
ELSE
RETURN FALSE (* error *)
END
END
END;
RETURN TRUE (* success *)
END ReadShortHex;
PROCEDURE ReadHex* (fh: Dos.FileHandlePtr; VAR i: INTEGER): BOOLEAN;
VAR n, j: INTEGER;
BEGIN
i := 0;
FOR n := 1 TO 4 DO
IF ReadHexDigit (fh, j) THEN
i := i*16 + j
ELSE IF n > 1 THEN
RETURN TRUE
ELSE
RETURN FALSE (* error *)
END
END
END;
RETURN TRUE (* success *)
END ReadHex;
PROCEDURE ReadLongHex* (fh: Dos.FileHandlePtr; VAR i: LONGINT): BOOLEAN;
VAR n, j: INTEGER;
BEGIN
i := 0;
FOR n := 1 TO 8 DO
IF ReadHexDigit (fh, j) THEN
i := i*16 + j
ELSE IF n > 1 THEN
RETURN TRUE
ELSE
RETURN FALSE (* error *)
END
END
END;
RETURN TRUE (* success *)
END ReadLongHex;
BEGIN IF Dos.base.lib.version < 37 THEN
SYSTEM.SETREG (0, Dos.Write (Dos.Output(), "Requires AmigaDOS version 2 or later.\n", 40));
HALT (Dos.fail)
END;
W := Dos.Output ();
R := Dos.Input ()
END BufIO.